home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / PC Backup266649182001.psc / modCommon.bas < prev    next >
Encoding:
BASIC Source File  |  2001-09-20  |  24.8 KB  |  734 lines

  1. Attribute VB_Name = "modCommon"
  2. Global NLoops As Integer, LoopDup As Integer, ListWithFocus As Boolean, Days As Byte
  3. Global sRet As String, Ret As Long, MskErr1 As Boolean, MskErr2 As Boolean
  4. Global DestinDir As String, NoIniArchive As Boolean, bDatedDir As Boolean, bCusDir As Boolean, bUseBoth As Boolean
  5. Global WindowsDir As String, NLoopsTimer As Byte, Interval As Date, IniTime As Date, prevDir As String
  6. Global Default As Boolean, LastBackup As Date, result As Long, Msg As Long, OpenError As Boolean
  7. Global XDir(2) As New Collection, FromPath As String, BaseDir As String, tmpPath As String, newPath As String, bBakNow As Boolean
  8.  
  9. Public Const Arq = "PCBak.ini"
  10. Public Const SW_SHOW = 5
  11.  
  12. Declare Function WritePrivateProfileString& Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As String, ByVal lpFileName As String)
  13. Declare Function GetPrivateProfileString& Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String)
  14. Declare Function GetWindowsDirectory& Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long)
  15. Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
  16.  
  17. Public Type NOTIFYICONDATA
  18.     cbSize As Long
  19.     hwnd As Long
  20.     uId As Long
  21.     uFlags As Long
  22.     uCallBackMessage As Long
  23.     hIcon As Long
  24.     szTip As String * 64
  25. End Type
  26.     
  27. Public Const NIM_ADD = &H0
  28. Public Const NIM_MODIFY = &H1
  29. Public Const NIM_DELETE = &H2
  30. Public Const NIF_MESSAGE = &H1
  31. Public Const NIF_ICON = &H2
  32. Public Const NIF_TIP = &H4
  33. Public Const WM_MOUSEMOVE = &H200
  34. Public Const WM_LBUTTONDOWN = &H201
  35. Public Const WM_LBUTTONUP = &H202
  36. Public Const WM_LBUTTONDBLCLK = &H203
  37. Public Const WM_RBUTTONDOWN = &H204
  38. Public Const WM_RBUTTONUP = &H205
  39. Public Const WM_RBUTTONDBLCLK = &H206
  40.  
  41. Public Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
  42. Public Declare Function Shell_NotifyIcon Lib "shell32" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, pnid As NOTIFYICONDATA) As Boolean
  43.  
  44. Public nid As NOTIFYICONDATA
  45.  
  46. Public Type ListaArqs
  47.     Nome As String
  48.     Tamanho As Long
  49. End Type
  50.  
  51. Public Files() As ListaArqs
  52. Private Type FILETIME
  53.     dwLowDateTime As Long
  54.     dwHighDateTime As Long
  55. End Type
  56. Option Explicit
  57. 'Menu item constants.
  58.       Private Const SC_CLOSE       As Long = &HF060&
  59.  
  60.       'SetMenuItemInfo fMask constants.
  61.       Private Const MIIM_STATE     As Long = &H1&
  62.       Private Const MIIM_ID        As Long = &H2&
  63.  
  64.       'SetMenuItemInfo fState constants.
  65.       Private Const MFS_GRAYED     As Long = &H3&
  66.       Private Const MFS_CHECKED    As Long = &H8&
  67.  
  68.       'SendMessage constants.
  69.       Private Const WM_NCACTIVATE  As Long = &H86
  70.  
  71.       'User-defined Types.
  72.       Private Type MENUITEMINFO
  73.           cbSize        As Long
  74.           fMask         As Long
  75.           fType         As Long
  76.           fState        As Long
  77.           wID           As Long
  78.           hSubMenu      As Long
  79.           hbmpChecked   As Long
  80.           hbmpUnchecked As Long
  81.           dwItemData    As Long
  82.           dwTypeData    As String
  83.           cch           As Long
  84.       End Type
  85.  
  86.       'Declarations.
  87.       Private Declare Function GetSystemMenu Lib "user32" ( _
  88.           ByVal hwnd As Long, ByVal bRevert As Long) As Long
  89.  
  90.       Private Declare Function GetMenuItemInfo Lib "user32" Alias _
  91.           "GetMenuItemInfoA" (ByVal hMenu As Long, ByVal un As Long, _
  92.           ByVal b As Boolean, lpMenuItemInfo As MENUITEMINFO) As Long
  93.  
  94.       Private Declare Function SetMenuItemInfo Lib "user32" Alias _
  95.           "SetMenuItemInfoA" (ByVal hMenu As Long, ByVal un As Long, _
  96.           ByVal bool As Boolean, lpcMenuItemInfo As MENUITEMINFO) As Long
  97.  
  98.       Private Declare Function SendMessage Lib "user32" Alias _
  99.           "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, _
  100.           ByVal wParam As Long, lParam As Any) As Long
  101.  
  102.       'Application-specific constants and variables.
  103.       Private Const xSC_CLOSE  As Long = -10
  104.       Private Const SwapID     As Long = 1
  105.       Private Const ResetID    As Long = 2
  106.  
  107.       Private hMenu  As Long
  108.       Private MII    As MENUITEMINFO
  109.  
  110. Public Const GW_HWNDPREV = 3
  111. Declare Function OpenIcon Lib "user32" (ByVal hwnd As Long) As Long
  112. Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
  113. Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
  114.  
  115.  
  116. Function ActivatePrevInstance()
  117.     Dim OldTitle As String
  118.     Dim PrevHndl As Long
  119.     Dim result As Long
  120.     'Save the title of the application.
  121.     OldTitle = App.Title
  122.     'Rename the title of this application so
  123.     '     FindWindow
  124.     'will not find this application instance
  125.     '     .
  126.     App.Title = "unwanted instance"
  127.     'Attempt to get window handle using VB4
  128.     '     class name.
  129.     PrevHndl = FindWindow("ThunderRTMain", OldTitle)
  130.     'Check for no success.
  131.  
  132.  
  133.     If PrevHndl = 0 Then
  134.         'Attempt to get window handle using VB5
  135.         '     class name.
  136.         PrevHndl = FindWindow("ThunderRT5Main", OldTitle)
  137.     End If
  138.     'Check if found
  139.  
  140.  
  141.     If PrevHndl = 0 Then
  142.         'Attempt to get window handle using VB6
  143.         '     class name
  144.         PrevHndl = FindWindow("ThunderRT6Main", OldTitle)
  145.     End If
  146.     'Check if found
  147.  
  148.  
  149.     If PrevHndl = 0 Then
  150.         'No previous instance found.
  151.         Exit Function
  152.     End If
  153.     'Get handle to previous window.
  154.     PrevHndl = GetWindow(PrevHndl, GW_HWNDPREV)
  155.     'Restore the program.
  156.     result = OpenIcon(PrevHndl)
  157.     'Activate the application.
  158.     result = SetForegroundWindow(PrevHndl)
  159.     'End the application.
  160.     End
  161. End Function
  162.  
  163. Function SetId(Action As Long) As Long
  164.           Dim MenuID As Long
  165.           Dim Ret As Long
  166.  
  167.           MenuID = MII.wID
  168.           If MII.fState = (MII.fState Or MFS_GRAYED) Then
  169.               If Action = SwapID Then
  170.                   MII.wID = SC_CLOSE
  171.               Else
  172.                   MII.wID = xSC_CLOSE
  173.               End If
  174.           Else
  175.               If Action = SwapID Then
  176.                   MII.wID = xSC_CLOSE
  177.               Else
  178.                   MII.wID = SC_CLOSE
  179.               End If
  180.           End If
  181.  
  182.           MII.fMask = MIIM_ID
  183.           Ret = SetMenuItemInfo(hMenu, MenuID, False, MII)
  184.           If Ret = 0 Then
  185.               MII.wID = MenuID
  186.           End If
  187.           SetId = Ret
  188.       End Function
  189.  
  190.  
  191.  
  192. Function Initialize()
  193. On Error GoTo erro
  194.  
  195.     Dim Lenght As Byte
  196.     
  197.     WindowsDir = String(255, 0)
  198.     Lenght = GetWindowsDirectory(WindowsDir, 254)
  199.     WindowsDir = Left(WindowsDir, Lenght)
  200.     
  201.     If Not Right(WindowsDir, 1) = "\" Then WindowsDir = WindowsDir & "\"
  202.     
  203.     If Dir(WindowsDir & "PCBak.ini") = "" Then
  204.         If Dir(WindowsDir & "PCBak.bak") <> "" Then
  205.             FileCopy WindowsDir & "PCBak.bak", WindowsDir & "PCBak.ini"
  206.         Else
  207.             NoIniArchive = True
  208.         End If
  209.     End If
  210.         
  211.     sRet = String(255, 0)
  212.     Ret = GetPrivateProfileString("When", "AlwaysAt", "", sRet, 255, Arq)
  213.     sRet = Left(sRet, Ret)
  214.     If Not Ret = 0 Then
  215.         If sRet = "???" Then
  216.             IniTime = vbEmpty
  217.         Else
  218.             frmMain.MaskEdBox1.Text = sRet
  219.             IniTime = TimeSerial(Hour(frmMain.MaskEdBox1.Text), Minute(frmMain.MaskEdBox1.Text), 0)
  220.         End If
  221.     End If
  222.  
  223.     sRet = String(255, 0)
  224.     Ret = GetPrivateProfileString("When", "Each", "", sRet, 255, Arq)
  225.     sRet = Left(sRet, Ret)
  226.     If Not Ret = 0 Then
  227.         If sRet = "???" Then
  228.             Interval = vbEmpty
  229.         Else
  230.             frmMain.MaskEdBox2.Text = sRet
  231.             Interval = TimeSerial(Hour(frmMain.MaskEdBox2.Text), Minute(frmMain.MaskEdBox2.Text), 0)
  232.         End If
  233.     End If
  234.     
  235.     sRet = String(255, 0)
  236.     Ret = GetPrivateProfileString("When", "Default", "", sRet, 255, Arq)
  237.     sRet = Left(sRet, Ret)
  238.     If Not Ret = 0 Then
  239.         If sRet = "False" Then
  240.             Default = False
  241.         Else
  242.             Default = True
  243.         End If
  244.     End If
  245.     
  246.     sRet = String(255, 0)
  247.     Ret = GetPrivateProfileString("When", "Days", "", sRet, 255, Arq)
  248.     sRet = Left(sRet, Ret)
  249.     If Not Ret = 0 Then
  250.         Dim BsRet As Byte
  251.         BsRet = CByte(sRet)
  252.         If Int(BsRet / 64) = 1 Then frmMain.chkDays(7).Value = True: BsRet = BsRet - 64
  253.         If Int(BsRet / 32) = 1 Then frmMain.chkDays(6).Value = True: BsRet = BsRet - 32
  254.         If Int(BsRet / 16) = 1 Then frmMain.chkDays(5).Value = True: BsRet = BsRet - 16
  255.         If Int(BsRet / 8) = 1 Then frmMain.chkDays(4).Value = True: BsRet = BsRet - 8
  256.         If Int(BsRet / 4) = 1 Then frmMain.chkDays(3).Value = True: BsRet = BsRet - 4
  257.         If Int(BsRet / 2) = 1 Then frmMain.chkDays(2).Value = True: BsRet = BsRet - 2
  258.         If Int(BsRet / 1) = 1 Then frmMain.chkDays(1).Value = True
  259.     End If
  260.     
  261.     sRet = String(255, 0)
  262.     Ret = GetPrivateProfileString("Log", "Save", "", sRet, 255, Arq)
  263.     sRet = Left(sRet, Ret)
  264.     If Not Ret = 0 Then If sRet = "False" Then frmMain.chkLog.Value = False
  265.     
  266.     sRet = String(255, 0)
  267.     Ret = GetPrivateProfileString("Backup", "Incremental", "", sRet, 255, Arq)
  268.     sRet = Left(sRet, Ret)
  269.     If Not Ret = 0 Then If sRet = "True" Then frmMain.chkIncr.Value = True
  270.     
  271.     sRet = String(255, 0)
  272.     Ret = GetPrivateProfileString("Destination", "BaseDir", "", sRet, 255, Arq)
  273.     sRet = Left(sRet, Ret)
  274.     If Not Ret = 0 Then
  275.         On Error GoTo erro1
  276.         frmMain.dirDest.Path = sRet
  277.         frmMain.driveDest.Drive = Left(sRet, 2)
  278.         On Error GoTo erro
  279.     End If
  280.     DestinDir = sRet
  281.     sRet = String(255, 0)
  282.     Ret = GetPrivateProfileString("Destination", "Custom", "", sRet, 255, Arq)
  283.     sRet = Left(sRet, Ret)
  284.     If Not Ret = 0 Then If sRet = "True" Then frmMain.chkCustom.Value = True
  285.         
  286.     sRet = String(255, 0)
  287.     Ret = GetPrivateProfileString("Destination", "CustomName", "", sRet, 255, Arq)
  288.     sRet = Left(sRet, Ret)
  289.    If Not Ret = 0 Then frmMain.txtCusDir = sRet
  290.     DestinDir = DestinDir & sRet
  291.     
  292.     sRet = String(255, 0)
  293.     Ret = GetPrivateProfileString("Destination", "And", "", sRet, 255, Arq)
  294.     sRet = Left(sRet, Ret)
  295.     If Not Ret = 0 Then If sRet = "True" Then frmMain.optAnd.Value = True
  296.     
  297.     sRet = String(255, 0)
  298.     Ret = GetPrivateProfileString("Destination", "Or", "", sRet, 255, Arq)
  299.     sRet = Left(sRet, Ret)
  300.     If Not Ret = 0 Then If sRet = "True" Then frmMain.optOr.Value = True
  301.     
  302.     sRet = String(255, 0)
  303.     Ret = GetPrivateProfileString("Destination", "DatedDirectories", "", sRet, 255, Arq)
  304.     sRet = Left(sRet, Ret)
  305.     If Not Ret = 0 Then If sRet = "True" Then frmMain.chkDated.Value = True
  306.     'DestinDir = DestinDir & sRet
  307.     
  308.     sRet = String(255, 0)
  309.     Ret = GetPrivateProfileString("Destination", "DateSeperator", "", sRet, 255, Arq)
  310.     sRet = Left(sRet, Ret)
  311.     If Not Ret = 0 Then frmMain.cmbSep = sRet
  312.     
  313.     sRet = String(255, 0)
  314.     Ret = GetPrivateProfileString("Options", "LoadWin", "", sRet, 255, Arq)
  315.     sRet = Left(sRet, Ret)
  316.     If Not Ret = 0 Then If sRet = "True" Then frmMain.chkServ.Value = True
  317.  
  318.     
  319. cont:
  320.     'DestinDir = sRet
  321.     'frmMain.txtDest.Text = DestinDir
  322.     NLoops = 0
  323.     ReDim Files(0)
  324.     
  325.     
  326. start:
  327.     sRet = String(255, 0)
  328.     Ret = GetPrivateProfileString("Entries", NLoops, "", sRet, 255, Arq)
  329.     If Ret = 0 Then LastBackup = TimeSerial(Hour(Time), Minute(Time), 0): Exit Function
  330.     sRet = Left(sRet, Ret)
  331.     frmMain.lstSource.AddItem sRet
  332.     NLoops = NLoops + 1
  333.     GoTo start
  334.  
  335. recheckItems
  336. Saφda:
  337.     Exit Function
  338.     
  339. erro:
  340.     MsgBox Err.Number & vbLf & vbLf & Err.Description, vbCritical, "Initializing!"
  341.     Resume Next
  342.     
  343. erro1:
  344.     If Err.Number = 68 Or Err.Number = 76 Then
  345.     
  346.     Else
  347.         MsgBox Err.Number & vbLf & Err.Description
  348.     End If
  349.     Resume cont
  350.     
  351. End Function
  352.  
  353. Function AddItem(OnlyFile As Boolean, Optional WithSubs As Boolean = False)
  354. On Error GoTo erro
  355.  
  356.     Screen.MousePointer = vbHourglass
  357.  
  358.     Dim AddPath As String
  359.     
  360.     If Right(frmMain.dirSource.List(frmMain.dirSource.ListIndex), 1) = "\" Then
  361.         AddPath = frmMain.dirSource.List(frmMain.dirSource.ListIndex)
  362.     Else
  363.         AddPath = frmMain.dirSource.List(frmMain.dirSource.ListIndex) & "\"
  364.     End If
  365.     
  366.     If Not OnlyFile Then
  367.         
  368.         If WithSubs Then
  369.             Dim i As Integer, d As String
  370.             GetDirs (AddPath)
  371.             For i = 1 To XDir(0).Count
  372.                 If VerificaDup(XDir(0).Item(i) & "\*.*") Then
  373.                     MsgBox "This item is already on the list:" & vbLf & vbLf & XDir(0).Item(i) & "\*.*", vbExclamation
  374.                 Else
  375.                     frmMain.lstSource.AddItem XDir(0).Item(i) & "\*.*"
  376.                 End If
  377.             Next i
  378.             For i = XDir(0).Count To 1 Step -1
  379.                 XDir(0).Remove (i)
  380.             Next i
  381.         End If
  382.         
  383.         If frmMain.lstSource.ListCount = 0 Then
  384.             frmMain.lstSource.AddItem AddPath & "*.*"
  385.             GoTo Saφda
  386.         Else
  387.             If VerificaDup(AddPath & "*.*") Then
  388.                 MsgBox "This item is already on the list:" & vbLf & vbLf & AddPath & "*.*", vbExclamation
  389.                 GoTo Saφda
  390.             Else
  391.                 frmMain.lstSource.AddItem AddPath & "*.*"
  392.                 GoTo Saφda
  393.             End If
  394.         End If
  395.         
  396.     Else
  397.     
  398.         Dim Entries As Integer
  399.         For NLoops = 0 To frmMain.fileSource.ListCount - 1
  400.             If frmMain.fileSource.Selected(NLoops) Then
  401.                 Entries = Entries + 1
  402.                 If Entries > 1 Then GoTo cont
  403.             End If
  404.         Next NLoops
  405.  
  406. cont:
  407.         If Entries = 1 Then
  408.             If VerificaDup(AddPath & frmMain.fileSource.FileName) Then
  409.                 MsgBox "This item is already on the list:" & vbLf & vbLf & AddPath & frmMain.fileSource.FileName, vbExclamation
  410.                 GoTo Saφda
  411.             Else
  412.                 frmMain.lstSource.AddItem AddPath & frmMain.fileSource.FileName
  413.                 GoTo Saφda
  414.             End If
  415.         ElseIf Entries > 1 Then
  416.             For NLoops = 0 To frmMain.fileSource.ListCount - 1
  417.                 If frmMain.fileSource.Selected(NLoops) Then
  418.                     If VerificaDup(AddPath & frmMain.fileSource.List(NLoops)) Then
  419.                         MsgBox "This item is already on the list:" & vbLf & vbLf & AddPath & frmMain.fileSource.List(NLoops), vbExclamation
  420.                     Else
  421.                         frmMain.lstSource.AddItem AddPath & frmMain.fileSource.List(NLoops)
  422.                     End If
  423.                 End If
  424.             Next NLoops
  425.         End If
  426.         
  427.     End If
  428.     
  429. Saφda:
  430.     Screen.MousePointer = vbDefault
  431.     Exit Function
  432.     
  433. erro:
  434.     MsgBox Err.Number & vbLf & Err.Description, vbCritical
  435.     Resume Saφda
  436.                     
  437. End Function
  438.  
  439. Function recheckItems()
  440. Dim i As Integer, d As String, n As Integer, strPath As String
  441. For n = 0 To frmMain.lstSource.ListCount - 1
  442.     strPath = frmMain.lstSource.List(n)
  443.     If Right(strPath, 4) = "\*.*" Then
  444.         strPath = Left(strPath, Len(strPath) - 3)
  445.     End If
  446.     GetDirs (strPath)
  447.     For i = 1 To XDir(0).Count
  448.         If Not VerificaDup(XDir(0).Item(i) & "\*.*") Then
  449.             frmMain.lstSource.AddItem XDir(0).Item(i) & "\*.*"
  450.         End If
  451.     Next i
  452.     For i = XDir(0).Count To 1 Step -1
  453.         XDir(0).Remove (i)
  454.     Next i
  455.     Dim Entries As Integer
  456.     For NLoops = 0 To frmMain.fileSource.ListCount - 1
  457.         If frmMain.fileSource.Selected(NLoops) Then
  458.             Entries = Entries + 1
  459.             If Entries > 1 Then GoTo cont
  460.         End If
  461.     Next NLoops
  462.  
  463. cont:
  464.     If Entries = 1 Then
  465.         If Not VerificaDup(strPath & frmMain.fileSource.FileName) Then
  466.             frmMain.lstSource.AddItem strPath & frmMain.fileSource.FileName
  467.         End If
  468.     ElseIf Entries > 1 Then
  469.         For NLoops = 0 To frmMain.fileSource.ListCount - 1
  470.             If frmMain.fileSource.Selected(NLoops) Then
  471.                 If Not VerificaDup(strPath & frmMain.fileSource.List(NLoops)) Then
  472.                     frmMain.lstSource.AddItem strPath & frmMain.fileSource.List(NLoops)
  473.                 End If
  474.             End If
  475.         Next NLoops
  476.     End If
  477.  
  478. Next n
  479. End Function
  480.  
  481. Function GetDirs(Path As String)
  482.     'on error Resume Next
  483.     Dim vDirName As String, LastDir As String
  484.     Dim i As Integer
  485.     
  486.     'Adjust so No Deletion of Drive
  487.     If Len(Path$) < 3 Then Exit Function
  488.  
  489.     If Right(Path$, 1) <> "\" Then
  490.         XDir(0).Add Path$
  491.         Path$ = Path$ & "\"
  492.     End If
  493.  
  494.     vDirName = Dir(Path, vbDirectory) ' Retrieve the first entry.
  495.  
  496.     Do While vDirName <> ""
  497.         If vDirName <> "." And vDirName <> ".." Then
  498.             If (GetAttr(Path & vDirName)) = vbDirectory Then
  499.                 LastDir = vDirName
  500.                 'Finds Directory Name then Repeats
  501.                 GetDirs (Path$ & vDirName)
  502.                 vDirName = Dir(Path$, vbDirectory)
  503.  
  504.                 Do Until vDirName = LastDir Or vDirName = ""
  505.                     vDirName = Dir
  506.                 Loop
  507.  
  508.                 If vDirName = "" Then Exit Do
  509.             End If
  510.         End If
  511.     
  512.     vDirName = Dir
  513.     
  514.     Loop
  515.  
  516. End Function
  517.  
  518. Function ExtractText(FullText As String, token As String, Optional StartAtLeft = True, Optional IncludeLeftSide = True) As String
  519. 'ExtractText(Path$, ":", False, False)
  520.     
  521.     Dim i As Integer
  522.     If StartAtLeft = True And IncludeLeftSide = True Then
  523.         ExtractText = FullText
  524.         For i = 1 To Len(FullText)
  525.             If Mid(FullText, i, 1) = token Then
  526.                 ExtractText = Left(FullText, i - 1)
  527.                 Exit Function
  528.             End If
  529.         Next
  530.  
  531.     ElseIf StartAtLeft = True And IncludeLeftSide = False Then
  532.         ExtractText = FullText
  533.         For i = 1 To Len(FullText)
  534.             If Mid(FullText, i, 1) = token Then
  535.                 ExtractText = Right(FullText, Len(FullText) - i)
  536.                 Exit Function
  537.             End If
  538.         Next
  539.     
  540.     ElseIf StartAtLeft = False And IncludeLeftSide = True Then
  541.         ExtractText = ""
  542.         For i = Len(FullText) To 1 Step -1
  543.             If Mid(FullText, i, 1) = token Then
  544.                 ExtractText = Left(FullText, i - 1)
  545.                 Exit Function
  546.             End If
  547.         Next
  548.  
  549.     ElseIf StartAtLeft = False And IncludeLeftSide = False Then
  550.         ExtractText = ""
  551.         For i = Len(FullText) To 1 Step -1
  552.             If Mid(FullText, i, 1) = token Then
  553.                 ExtractText = Right(FullText, Len(FullText) - i)
  554.                 Exit Function
  555.             End If
  556.         Next
  557.     End If
  558.  
  559. End Function
  560.  
  561.  
  562. Function MtxAdicionaArq(CamCompleto As String)
  563.     
  564.     If UBound(Files) = 1 Then
  565.         Files(1).Nome = CamCompleto
  566.         Files(1).Tamanho = FileLen(CamCompleto)
  567.         ReDim Preserve Files(2)
  568.     Else
  569.         Files(UBound(Files)).Nome = CamCompleto
  570.         Files(UBound(Files)).Tamanho = FileLen(CamCompleto)
  571.         ReDim Preserve Files(UBound(Files) + 1)
  572.     End If
  573.  
  574. End Function
  575.  
  576. Function MtxAdicionaDir(ByVal Caminho As String)
  577. On Error GoTo erro
  578.  
  579.     Dim b As String, n As Integer, ShortPath As String
  580.     
  581.     If Not Right(Caminho, 1) = "*" Then Caminho = Caminho & "*.*"
  582.  
  583.     ShortPath = Left(Caminho, Len(Caminho) - 3)
  584.  
  585.     If Not UBound(Files) = 1 Then
  586.         n = UBound(Files) + 1
  587.         ReDim Preserve Files(n)
  588.     End If
  589.     
  590.     b = Dir(Caminho)
  591.     If b = "" Then
  592.         Exit Function
  593.     Else
  594.         Files(UBound(Files) - 1).Nome = ShortPath & b
  595.         Files(UBound(Files) - 1).Tamanho = FileLen(ShortPath & b)
  596.     End If
  597.  
  598.     Do
  599.     b = Dir
  600.     If b = "" Then Exit Do
  601.         
  602.     With Files(n)
  603.         .Nome = ShortPath & b
  604.         .Tamanho = FileLen(ShortPath & b)
  605.     End With
  606.     n = n + 1
  607.     ReDim Preserve Files(n)
  608.     Loop
  609.  
  610. Saφda:
  611.     Exit Function
  612.     
  613. erro:
  614.     MsgBox "MtxAddDir:" & vbLf & vbLf & Err.Number & ":" & Err.Description, vbCritical
  615.     Resume Saφda
  616.  
  617. End Function
  618.  
  619. Function Backup()
  620. On Error GoTo erro
  621.  
  622.     Screen.MousePointer = vbHourglass
  623.     
  624.     Dim DateBak As Date, TimeBak As Date, ErrString As String
  625.     Dim NDirs As Integer, File As String, TskID As Double, TotFiles As Long, TotalFilesCopied As Long
  626.     Dim ErroDest As Byte, ArqAtr As Byte, Tam As Long, dirFolder As String, r As Boolean, srcTmp As String, destFile As String, destpath As String
  627.     Dim FileCnt As Long, rdOnly As Boolean
  628.     recheckItems
  629.     frmMain.SSTab1.Tab = 6
  630.     
  631.     TimeBak = Now
  632.     DateBak = Date
  633.     
  634.     frmMain.Caption = "Creating file list..."
  635.     DestinDir = frmMain.txtDest
  636.     dirFolder = Dir$(DestinDir, vbDirectory)
  637.     If dirFolder = "" Then
  638.         MkDir (DestinDir)
  639.     End If
  640.     If Not Right(DestinDir, 1) = "\" Then DestinDir = DestinDir & "\"
  641.  
  642.     For NLoops = 0 To frmMain.lstSource.ListCount - 1
  643.         If Right(frmMain.lstSource.List(NLoops), 1) = "*" Then
  644.             MtxAdicionaDir (Left(frmMain.lstSource.List(NLoops), Len(frmMain.lstSource.List(NLoops)) - 3))
  645.         Else
  646.             MtxAdicionaArq (frmMain.lstSource.List(NLoops))
  647.         End If
  648.     Next NLoops
  649.  
  650.     frmMain.Caption = "Doing the backup..."
  651.     If frmMain.chkLog Then
  652.         Open WindowsDir & "PCBak.log" For Output As #1
  653.         Print #1, "Initializing backup at " & Now
  654.         Print #1,
  655.     End If
  656.     
  657.     frmMain.Label10.Caption = "Copying from"
  658.     frmMain.Label12.Caption = "to"
  659.     
  660.     FileCnt = UBound(Files)
  661.     TotFiles = UBound(Files) - 1
  662.     For NLoops = 0 To TotFiles
  663.         DoEvents
  664.         If Not Files(NLoops).Nome = "" Then
  665.             ArqAtr = GetAttr(Files(NLoops).Nome)
  666.  
  667.  
  668. cont:
  669.             srcTmp = Files(NLoops).Nome
  670.             destFile = ReturnFileName(srcTmp)
  671.             'destFile = ReturnFileName(srcTmp)
  672.             If destFile = "" Then GoTo Saφda
  673.             If frmMain.chkIncr Then
  674.                 If ArqAtr = vbReadOnly Then rdOnly = True
  675.                 If ArqAtr And vbArchive <> 0 Then
  676.                     destpath = GetParentDir(Left(srcTmp, (Len(srcTmp) - Len(destFile))))
  677.                     FileCopy srcTmp, destpath & destFile
  678.                     If frmMain.chkLog Then Print #1, srcTmp & " --> " & destpath & destFile & ", status: ";
  679.                     If Not rdOnly Then
  680.                         SetAttr srcTmp, (ArqAtr - vbArchive)
  681.                     End If
  682.                     If frmMain.chkLog Then Print #1, "Ok!"
  683.                     Tam = Tam + FileLen(srcTmp)
  684.                     TotalFilesCopied = TotalFilesCopied + 1
  685.                 End If
  686.             Else
  687.                 destpath = GetParentDir(Left(srcTmp, (Len(srcTmp) - Len(destFile))))
  688.                 FileCopy srcTmp, destpath & destFile
  689.                 If frmMain.chkLog Then Print #1, srcTmp & " --> " & destpath & destFile & ", status: ";
  690.                 If frmMain.chkLog Then Print #1, "Ok!"
  691.                 Tam = Tam + FileLen(srcTmp)
  692.                 TotalFilesCopied = TotalFilesCopied + 1
  693.             End If
  694.             frmMain.Label11.Caption = srcTmp
  695.             frmMain.Label13.Caption = destpath & destFile
  696.             frmMain.Label14.Caption = "File " & NLoops & " of " & FileCnt
  697.             frmMain.Label14.Caption = "File " & NLoops & " of " & FileCnt & ", total: " & _
  698.                         Format(Tam / 1024 / 1024, "standard") & " Mb"
  699.         End If
  700.     Next NLoops
  701.  
  702. Saφda:
  703.     If srcTmp <> "" Then
  704.         If frmMain.chkLog Then
  705.             Print #1,
  706.             Print #1, "Copied " & TotalFilesCopied & " files, " & Format(Tam / 1024 / 1024, "standard") & " Mb, From " & _
  707.                 Format(TimeBak, "short time") & " to " & Format(Time, "short time") & " on " & Format(DateBak, "short date") & "."
  708.             Close #1
  709.         End If
  710.     End If
  711.     frmMain.Label10.Caption = ""
  712.     frmMain.Label11.Caption = ""
  713.     frmMain.Label12.Caption = ""
  714.     frmMain.Label13.Caption = ""
  715.     frmMain.Label14.Caption = "Copied " & TotalFilesCopied & " files, " & Format(Tam / 1024 / 1024, "standard") & " Mb, From " & _
  716.                 Format(TimeBak, "short time") & " to " & Format(Time, "short time") & " on " & Format(DateBak, "short date") & "."
  717.     ReDim Files(0)
  718.     frmMain.Caption = "PC Backup ver 1.0"
  719.     Screen.MousePointer = vbDefault
  720.     Exit Function
  721. s).Nome = "" T(dte Const MIIM_STkction
  722. s).Nomption = " & NLoops & " ocreen.)
  723.  "ction
  724. s).Nometion
  725. s).No     
  726. ctring
  727.     Dim i As Iext Function
  728.  
  729.    End If
  730.             Else
  731.   m i A    Ai) &     sRenct A    Ai)msDefault
  732.     Exit FingConr 1.0"
  733.     ScreiKI4 / 102AateBak, "short date") & "."
  734.     ReDim Files(0)
  735.     frmMa           If frmMaino